home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / MacGofer 0.22d / MacGofer Sources / machine.c < prev    next >
Encoding:
Text File  |  1994-03-22  |  36.8 KB  |  500 lines  |  [TEXT/MPS ]
  1. ---------------------------------------*/
  2.  
  3. static    Label          nextLab;           /* next label number to allocate    */
  4. #define SHOULDNTFAIL  (-1)
  5. #define RUNON          (-2)
  6. #define UPDRET          (-3)
  7. #define VALRET          (-4)
  8. #if DYNAMIC_STORAGE
  9.     Addr          *fixups;
  10. #else
  11. static    Addr          fixups[NUM_FIXUPS]; /* fixup table maps Label -> Addr*/
  12. #endif
  13. #define atLabel(n)    fixups[n] = getMem(0)
  14. #define endLabel(d,l) if (d==RUNON) atLabel(l)
  15. #define fix(a)          addrAt(a) = fixups[labAt(a)]
  16.  
  17. static Void local asSTART() {           /* initialise assembler           */
  18.     fixups[0]    = noMatch;
  19.     nextLab    = 1;
  20.     startInstr    = getMem(0);
  21.     lastInstr    = startInstr-1;
  22.     srsp    = 0;
  23.     offsPosn[0] = 0;
  24. }
  25.  
  26. static Label local newLabel(d)           /* allocate new label           */
  27. Label d; {
  28.     if (d==RUNON) {
  29.     if (nextLab>=num_fixups) {
  30.         ERROR(0) "Compiled code too complex (need more than %d fixups)",
  31.         num_fixups
  32.         EEND;
  33.     }
  34.     return nextLab++;
  35.     }
  36.     return d;
  37. }
  38.  
  39. static Void local asEND() {           /* Fix addresses in assembled code  */
  40.     Addr pc = startInstr;
  41.  
  42.     while (pc<=lastInstr)
  43.     switch (instrAt(pc)) {
  44.         case iEVAL     :           /* opcodes taking no arguments       */
  45.         case iFAIL     :
  46.         case iRETURN : pc++;
  47.                break;
  48.  
  49.         case iGOTO     : fix(pc+1);  /* opcodes taking one argument       */
  50.         case iSETSTK :
  51.         case iALLOC  :
  52.         case iSLIDE  :
  53.         case iROOT     :
  54.             case iDICT   :
  55.         case iLOAD     :
  56.         case iCELL     :
  57.         case iCHAR     :
  58.         case iINT     :
  59. #if !BREAK_FLOATS
  60.         case iFLOAT  :
  61.  #endif
  62.         case iSTRING :
  63.         case iMKAP     :
  64.         case iUPDATE :
  65.         case iUPDAP  : pc+=2;
  66.                break;
  67. #if BREAK_FLOATS
  68.         case iFLOAT  : pc+=3;
  69.                break;
  70. #endif
  71.  
  72.         case iINTGE  :           /* opcodes taking two arguments       */
  73.         case iINTEQ  :
  74.         case iINTDV     :
  75.         case iTEST     : fix(pc+2);
  76.                pc+=3;
  77.                break;
  78.  
  79.         default     : internal("fixAddrs");
  80.     }
  81. }
  82.  
  83. /* --------------------------------------------------------------------------
  84.  * Assembler Opcodes: (includes simple peephole optimisations)
  85.  * ------------------------------------------------------------------------*/
  86.  
  87. #define asINTEGER(n) instrInt(iINT,n);        srsp++
  88. #define asFLOAT(fl)  instrFloat(iFLOAT,fl);    srsp++
  89. #define asSTRING(t)  instrText(iSTRING,t);    srsp++
  90. #define asCHAR(n)    instrInt(iCHAR,n);        srsp++
  91. #define asLOAD(n)    instrInt(iLOAD,n);        srsp++
  92. #define asALLOC(n)   instrInt(iALLOC,n);    srsp+=n
  93. #define asROOT(n)    instrInt(iROOT,n);        srsp++
  94. #define asSETSTK(n)  instrInt(iSETSTK,n);    srsp=n
  95. #define asEVAL()     instrNone(iEVAL);        srsp--    /* inaccurate srsp */
  96. #define asRETURN()   instrNone(iRETURN)
  97. #define asCELL(c)    instrCell(iCELL,c);    srsp++
  98. #define asTEST(c,l)  instrCellLab(iTEST,c,l)        /* inaccurate srsp */
  99. #define asINTGE(n,l) instrIntLab(iINTGE,n,l)        /* inaccurate srsp */
  100. #define asINTEQ(n,l) instrIntLab(iINTEQ,n,l)
  101. #define asINTDV(n,l) instrIntLab(iINTDV,n,l)        /* inaccurate srsp */
  102. #define asFAIL()     instrNone(iFAIL)
  103.  
  104. static Void local asDICT(n)        /* pick element of dictionary       */
  105. Int n; {
  106. /* Sadly, the following optimisation cannot be used unless CELL references
  107.  * in compiled code are garbage collected (and possibly modified when cell  
  108.  * indirections are found).
  109.  *
  110.  *    if (instrAt(lastInstr)==iCELL)
  111.  *    -- Peephole optimisation: CELL {dict m};DICT n ==> CELL dict(m+n)
  112.  *    if (whatIs(cellAt(lastInstr+1))==DICTCELL)
  113.  *        cellAt(lastInstr+1) = dict(dictOf(cellAt(lastInstr+1))+n);
  114.  *    else
  115.  *        internal("asDICT");
  116.  *    else  ...
  117.  */
  118.     if (n!=0)                /* optimisation:DICT 0 has no use  */
  119.     instrInt(iDICT,n);        /* for std dictionary construction */
  120. }
  121.  
  122. static Void local asSLIDE(n)        /* Slide results down stack       */
  123. Int n; {
  124.     if (instrAt(lastInstr)==iSLIDE)    /* Peephole optimisation:       */
  125.     intAt(lastInstr+1)+=n;        /* SLIDE n;SLIDE m ===> SLIDE (n+m)*/
  126.     else
  127.     instrInt(iSLIDE,n);
  128.     srsp -= n;
  129. }
  130.  
  131. static Void local asMKAP(n)        /* Make application nodes ...       */
  132. Int n; {
  133.     if (instrAt(lastInstr)==iMKAP)    /* Peephole optimisation:       */
  134.     intAt(lastInstr+1)+=n;        /* MKAP n; MKAP m  ===> MKAP (n+m) */
  135.     else
  136.     instrInt(iMKAP,n);
  137.     sr             root = sp;
  138.                  do {
  139.                      stack(root) = arg(stack(root-1));
  140.                      --root;
  141.                  } while (--ar>0);
  142.  
  143.                  if (name(n).primDef)        /* reduce       */
  144.                      (*name(n).primDef)(root);
  145.                  else
  146.                      run(name(n).code,root);
  147.  
  148.                  numReductions++;
  149.                  
  150.                  if(traceEval) {
  151.                     printf("===> ");
  152.                     printExp(stdout,svGraph);
  153.                     putchar('\n');
  154.                  }
  155.  
  156.                  sp = root;            /* continue... */
  157.                  n  = pop();
  158.                  }
  159.                  else {                /* CAF       */
  160.                  if (isNull(name(n).defn)) {/* build CAF   */
  161.                      push(n);            /* save CAF    */
  162.  
  163.                      if (name(n).primDef)
  164.                      (*name(n).primDef)(sp);
  165.                      else
  166.                      run(name(n).code,sp);
  167.  
  168.                      numReductions++;
  169.                  
  170.                      if(traceEval) {
  171.                            printf("===> ");
  172.                         printExp(stdout,svGraph);
  173.                         putchar('\n');
  174.                      }
  175.  
  176.  
  177.                      name(n).defn = pop();
  178.                      drop();            /* drop CAF    */
  179.                  }
  180.                  n = name(n).defn;        /*already built*/
  181.                  if (sp>base)
  182.                      fun(top()) = n;
  183.                  }
  184.                  goto unw;
  185.              }
  186.              break;
  187.  
  188.     case INTCELL   : whnfInt = intOf(n);
  189.              break;
  190.  
  191.         case FLOATCELL : assignFloat(n);
  192.              break;
  193.  
  194.     case STRCELL   : evalString(n);
  195.              goto unw;
  196.  
  197.     case FILECELL  : evalFile(n);
  198.              goto unw;
  199.     }
  200.  
  201.     whnfHead = n;               /* rearrange components of term on  */
  202.     whnfArgs = sp - base;           /* stack, now in whnf ...       */
  203.     for (ar=whnfArgs; ar>0; ar--) {
  204.     fun(stack(base+ar)) = n;
  205.     n            = stack(base+ar);
  206.     stack(base+ar)        = arg(n);
  207.     }
  208. }
  209.  
  210. Void unwind(n)                   /* unwind spine of application;       */
  211. Cell n; {                   /* like eval except that we always  */
  212.     whnfArgs = 0;               /* treat the expression n as if it  */
  213.                        /* were already in whnf.        */
  214. unw:switch (whatIs(n)) {
  215.     case AP        : push(arg(n));
  216.              whnfArgs++;
  217.              n = fun(n);
  218.              goto unw;
  219.  
  220.     case INDIRECT  : n = arg(n);
  221.              allowBreak();
  222.              goto unw;
  223.  
  224.     case INTCELL   : whnfInt = intOf(n);
  225.              break;
  226.  
  227.         case FLOATCELL : assignFloat(n);
  228.              break;
  229.  
  230.     case STRCELL   : evalString(n);
  231.              goto unw;
  232.     }
  233.     whnfHead = n;
  234. }
  235.  
  236. static Void local evalString(n)        /* expand STRCELL at node n       */
  237. Cell n; {
  238.     Text t = textOf(n);
  239.     Int  c = textToStr(t)[0];
  240.     if (c==0) {
  241.     fst(n) = INDIRECT;
  242.     snd(n) = nameNil;
  243.     return;
  244.     }
  245.     else if (c=='\\') {
  246.     c = textToStr(++t)[0];
  247.         if (c!='\\')
  248.         c = 0;
  249.     }
  250.     fst(n) = consChar(c);
  251.     snd(n) = mkStr(++t);
  252. }
  253.  
  254. static Void local run(start,root)      /* execute code beginning at given  */
  255. Addr     start;                   /* address with local stack starting*/
  256. StackPtr root; {               /* at given root offset           */
  257.     register Memory pc = memory+start;
  258.  
  259. #if     GCC_THREADED
  260. #define Ins(x)        &&l##x
  261. static  void *labs[] = { INSTRLIST };
  262. #undef  Ins
  263. #define Case(x)        l##x
  264. #define    Continue    goto *labs[(pc++)->instr]
  265. #define    Dispatch    Continue;
  266. #define EndDispatch
  267. #else
  268. #define Dispatch    for (;;) switch((pc++)->instr) {
  269. #define    Case(x)        case x
  270. #define    Continue    continue
  271. #define EndDispatch    default : internal("illegal instruction"); \
  272.                   break;               \
  273.             }
  274. #endif
  275.  
  276.     Dispatch
  277.  
  278.     Case(iLOAD)   : push(stack(root+pc->mint));     /* load from stack*/
  279.             pc++;
  280.             Continue;
  281.  
  282.     Case(iCELL)   : push(pc->cell);             /* load const Cell*/
  283.             pc++;
  284.             Continue;
  285.  
  286.     Case(iCHAR)   : push(mkChar(pc->mint));         /* load char const*/
  287.             pc++;
  288.             Continue;
  289.  
  290.     Case(iINT)    : push(mkInt(pc->mint));         /* load int const */
  291.             pc++;
  292.             Continue;
  293.  
  294. #if BREAK_FLOATS
  295.     Case(iFLOAT)  : push(mkFloat(floatFromParts     /* load dbl const */
  296.                 (pc->cell,(pc+1)->cell)));
  297.             pc+=2;
  298.             Continue;
  299. #else
  300.     Case(iFLOAT)  : push(mkFloat(pc->mfloat));     /* load float cnst*/
  301.             pc++;
  302.             Continue;
  303. #endif
  304.  
  305.     Case(iSTRING) : push(mkStr(pc->text));         /* load str const */
  306.             pc++;
  307.             Continue;
  308.  
  309.     Case(iMKAP)   : {   Cell t = pushed(0);         /* make AP nodes  */
  310.                 Int  i = pc->text;
  311.                 while (0<i--) {
  312.                 drop();
  313.                 t=ap(t,pushed(0));
  314.                 }
  315.                 pushed(0)=t;
  316.             }
  317.             pc++;
  318.             Continue;
  319.  
  320.     Case(iUPDATE) : {   Cell t = stack(root        /* update cell ...*/
  321.                          + pc->mint);
  322.                 fst(t) = INDIRECT;
  323.                 snd(t) = pop();
  324.             }
  325.             pc++;
  326.             Continue;
  327.  
  328.     Case(iUPDAP)  : {   Cell t = stack(root         /* update AP node */
  329.                          + pc->mint);
  330.                 fst(t) = pop();
  331.                 snd(t) = pop();
  332.             }
  333.             pc++;
  334.             Continue;
  335.  
  336.     Case(iEVAL)   : eval(pop());             /* evaluate top() */
  337.             Continue;
  338.  
  339.     Case(iRETURN) : return;                 /* terminate       */
  340.  
  341.     Case(iINTGE)  : if (whnfInt>=pc->mint) {     /* test integer >=*/
  342.                 push(mkInt(whnfInt-pc->mint));
  343.                 pc += 2;
  344.             }
  345.             else
  346.                 pc = memory + (pc+1)->addr;
  347.             Continue;
  348.  
  349.     Case(iINTEQ)  : if (whnfInt==pc->mint)         /* test integer ==*/
  350.                 pc += 2;
  351.             else
  352.                 pc = memory + (pc+1)->addr;
  353.             Continue;
  354.  
  355.     Case(iINTDV)  : if (whnfInt>=0 &&         /* test for mult  */
  356.                 (whnfInt%(pc->mint)==0)) {
  357.                 push(mkInt(whnfInt/(pc->mint)));
  358.                 pc += 2;
  359.             }
  360.             else
  361.                 pc = memory + (pc+1)->addr;
  362.             Continue;
  363.  
  364.     Case(iTEST)   : if (whnfHead==pc->cell)         /* test for cell  */
  365.                 pc += 2;
  366.             else
  367.                 pc = memory + (pc+1)->addr;
  368.             Continue;
  369.  
  370.     Case(iGOTO)   : pc = memory + pc->addr;         /* goto label       */
  371.             Continue;
  372.  
  373.     Case(iSETSTK) : sp=root + pc->mint;          /* set stack ptr  */
  374.             pc++;
  375.             Continue;
  376.  
  377.     Case(iALLOC)  : {   Int i = pc->mint;         /* alloc loc vars */
  378.                 chkStack(i);
  379.                 while (0<i--)
  380.                 onto(ap(NIL,NIL));
  381.             }
  382.             pc++;
  383.             Continue;
  384.  
  385.     Case(iDICT)   : top() = dict(dictOf(top()) + pc->mint);
  386.             pc++;                 /* dict lookup    */
  387.             Continue;
  388.  
  389.     Case(iROOT)   : {   Cell t = stack(root);     /* partial root   */
  390.                 Int  i = pc->mint;
  391.                 while (fst(t)==INDIRECT) {
  392.                 allowBreak();
  393.                 t = arg(t);
  394.                 }
  395.                 while (0<i--) {
  396.                 t = fun(t);
  397.                 while (fst(t)==INDIRECT) {
  398.                     allowBreak();
  399.                     t = arg(t);
  400.                 }
  401.                 }
  402.                 push(t);
  403.             }
  404.             pc++;
  405.             Continue;
  406.  
  407.     Case(iSLIDE)  : pushed(pc->mint) = top();     /* remove loc vars*/
  408.             sp -= pc->mint;
  409.             pc++;
  410.             Continue;
  411.  
  412.     Case(iFAIL)   : evalFails(root);         /* cannot reduce  */
  413.             return;/*NOT REACHED*/
  414.  
  415.     EndDispatch
  416.  
  417. #undef Dispatch
  418. #undef Case
  419. #undef Continue
  420. #undef EndDispatch
  421. }
  422.  
  423. Cell evalWithNoError(e)            /* Evaluate expression, returning   */
  424. Cell e; {                   /* NIL if successful, irreducible   */
  425.     Cell badRedex;               /* expression if not...           */
  426.     jmp_buf *oldCatch = evalError;
  427.  
  428. #if JMPBUF_ARRAY
  429.     jmp_buf catch[1];
  430.     evalError = catch;
  431.     if (setjmp(catch[0])==0) {
  432.     eval(e);
  433.     badRedex = NIL;
  434.     }
  435.     else
  436.     badRedex = errorRedex;
  437. #else
  438.     jmp_buf catch;
  439.     evalError = &catch;
  440.     if (setjmp(catch)==0) {
  441.         eval(e); 
  442.     badRedex = NIL;
  443.     }
  444.     else
  445.         badRedex = errorRedex;
  446. #endif
  447.  
  448.     evalError = oldCatch;
  449.     return badRedex;
  450. }
  451.  
  452. Void evalFails(root)            /* Eval of current redex fails       */
  453. StackPtr root; {
  454.     errorRedex = stack(root);        /* get error & bypass indirections */
  455.     while (isPair(errorRedex) && fst(errorRedex)==INDIRECT)
  456.     errorRedex = snd(errorRedex);
  457.  
  458.     if (failOnError)
  459.     abandon("Program",errorRedex);
  460.     else if (evalError)
  461.     longjmp(*evalError,1);
  462.     else
  463.     internal("uncaught eval error");
  464. }
  465.  
  466. Cell graphForExp() {            /* Build graph for expression to be*/
  467.     clearStack();            /* reduced...               */
  468.     run(inputCode,sp);
  469.     if(traceEval) {
  470.        svGraph = top();
  471.        printf(">>>> ");
  472.        printExp(stdout,svGraph);
  473.        putchar('\n');
  474.     }
  475.     return pop();
  476. }
  477.  
  478. /* --------------------------------------------------------------------------
  479.  * Machine control:
  480.  * ------------------------------------------------------------------------*/
  481.  
  482. Void machine(what)
  483. Int what; {
  484.     switch (what) {
  485.         case RESET   : svGraph = NIL;
  486.                    break;
  487.         case MARK    : mark(svGraph);
  488.                    break;            
  489.     case INSTALL : machine(RESET);
  490.                memory  = (Memory)farCalloc(num_addrs,sizeof(MemCell));
  491.                if (memory==0)
  492.                fatal("Cannot allocate program memory");
  493.                instrNone(iFAIL);
  494.                noMatch = lastInstr;
  495.                break;
  496.     }
  497. }
  498.  
  499. /* ------------------------------------------------------------------------*/
  500.